home *** CD-ROM | disk | FTP | other *** search
/ Workbench Add-On / Workbench Add-On - Volume 1.iso / Dev / Oberon / source / ProjectOberon / Reals.mod < prev    next >
Text File  |  1995-07-02  |  5KB  |  205 lines
  1. (***************************************************************************
  2.  
  3.      $RCSfile: Reals.mod $
  4.   Description: Low-level floating point conversions
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 1.9 $
  8.       $Author: fjc $
  9.         $Date: 1995/06/04 23:26:41 $
  10.  
  11.   Copyright © 1994, Frank Copeland.
  12.   This file is part of the Oberon-A Library.
  13.   See Oberon-A.doc for conditions of use and distribution.
  14.  
  15.   Log entries are at the end of the file.
  16.  
  17. ***************************************************************************)
  18.  
  19. MODULE Reals;
  20.  
  21. (*
  22. ** This module performs low-level operations on REAL and LONGREAL
  23. ** values. The values are assumed to be in IEEE floating-point format.
  24. ** At present both REAL and LONGREAL values are 32-bit single-precision
  25. ** values. In future LONGREAL will be re-implemented as 64-bit
  26. ** double-precision values.
  27. **
  28. ** IEEE single-precision reals have the following format:
  29. **
  30. ** SEEEEEEE EMMMMMMM MMMMMMMM MMMMMMMM
  31. ** 31       23       15       7
  32. **
  33. ** S = sign, E = exponent, M = mantissa
  34. *)
  35.  
  36. IMPORT SYS := SYSTEM;
  37.  
  38. (*------------------------------------*)
  39. PROCEDURE Expo* (x : REAL) : INTEGER;
  40. (*
  41. ** This procedure extracts the exponent part of a REAL value. This is
  42. ** held in bits 23-30.
  43. *)
  44.  
  45. BEGIN (* Expo *)
  46.   RETURN SHORT (SYS.LSH (SYS.VAL (LONGINT, x), -23)) MOD 256
  47. END Expo;
  48.  
  49. (*------------------------------------*)
  50. PROCEDURE ExpoL* (x : LONGREAL) : INTEGER;
  51.  
  52. BEGIN (* ExpoL *)
  53.   RETURN Expo (SHORT (x))
  54. END ExpoL;
  55.  
  56. (*------------------------------------*)
  57. PROCEDURE SetExpo* (e : INTEGER; VAR x : REAL);
  58. (*
  59.  * This procedure sets the exponent part of a REAL variable.  It clears bits
  60.  * 23-30 using SYS.AND() and ORs the exponent onto the cleared area.
  61.  *
  62.  * Broken down into simple expressions, the algorithm is:
  63.  *   i := SYS.VAL (LONGINT, x);
  64.  *   i := SYS.AND (i, 087FFFFFFH);
  65.  *   e := SYS.LSH (e MOD 256, 23);
  66.  *   i := SYS.LOR (i, e);
  67.  *   x := SYS.VAL (REAL, i)
  68.  *)
  69.  
  70. BEGIN (* SetExpo *)
  71.   x :=
  72.     SYS.VAL
  73.       ( REAL,
  74.         SYS.LOR
  75.           ( SYS.AND ( SYS.VAL (LONGINT, x), 087FFFFFFH ),
  76.             SYS.LSH (LONG (e MOD 256), 23) ) )
  77. END SetExpo;
  78.  
  79. (*------------------------------------*)
  80. PROCEDURE SetExpoL* (e : INTEGER; VAR x : LONGREAL);
  81.  
  82.   VAR y : REAL;
  83.  
  84. BEGIN (* SetExpoL *)
  85.   y := SHORT (x); SetExpo (e, y); x := LONG (y)
  86. END SetExpoL;
  87.  
  88. (*------------------------------------*)
  89. PROCEDURE Ten* (e : INTEGER) : REAL;
  90.  
  91.   VAR result : REAL; n : INTEGER;
  92.  
  93. BEGIN (* Ten *)
  94.   result := 1.0; n := ABS (e);
  95.   WHILE n > 0 DO result := result * 10.0; DEC (n) END;
  96.   (*                                    ^
  97.   ** If you get an F-line trap at this point, and you are the proud owner
  98.   ** of an Amiga 4000/040 running OS 3.1, this is *not* a compiler bug. You
  99.   ** need to install a patch to fix a bug in the V40
  100.   ** mathieeesingbas.library.
  101.   *)
  102.   IF e >= 0 THEN
  103.     RETURN result
  104.   ELSE
  105.     RETURN 1.0 / result
  106.   END;
  107. END Ten;
  108.  
  109. (*------------------------------------*)
  110. PROCEDURE TenL* (e : INTEGER) : LONGREAL;
  111.  
  112. BEGIN (* TenL *)
  113.   RETURN LONG (Ten (e))
  114. END TenL;
  115.  
  116. (*------------------------------------*)
  117. PROCEDURE Convert* (x : REAL; n : INTEGER; VAR d : ARRAY OF CHAR);
  118. (*
  119.  * Converts a REAL into a string.  d will contain the n most significant
  120.  * digits of x, in REVERSE order.
  121.  *)
  122.  
  123.   VAR i : LONGINT;
  124.  
  125. BEGIN (* Convert *)
  126.   i := 0;
  127.   REPEAT
  128.     d [i] := CHR (ENTIER (x) MOD 10 + 30H); x := x / 10; INC (i)
  129.   UNTIL i = n;
  130. END Convert;
  131.  
  132. (*------------------------------------*)
  133. PROCEDURE ConvertL* (x : LONGREAL; n : INTEGER; VAR d : ARRAY OF CHAR);
  134.  
  135. BEGIN (* ConvertL *)
  136.   Convert (SHORT (x), n, d)
  137. END ConvertL;
  138.  
  139. (*------------------------------------*)
  140. PROCEDURE ConvertH* (x : REAL; VAR d : ARRAY OF CHAR);
  141. (*
  142.  * Converts a REAL into a hexadecimal string.
  143.  *)
  144.  
  145.   VAR i, j, k : LONGINT;
  146.  
  147. BEGIN (* ConvertH *)
  148.   d [7] := 0X; (* This should cause an index trap if d is too small. *)
  149.   (* Turn off index checking now, since we know there is enough room. *)
  150.   <*$ < IndexChk- *>
  151.   k := SYS.VAL (LONGINT, x);
  152.   i := 8;
  153.   REPEAT
  154.     DEC (i);
  155.     IF k # 0 THEN
  156.       j := k MOD 10H; k := k DIV 10H;
  157.       IF j < 10 THEN d [i] := CHR (j + 30H) ELSE d [i] := CHR (j + 37H) END
  158.     ELSE
  159.       d [i] := "0"
  160.     END;
  161.   UNTIL i = 0;
  162.   <*$ > *>
  163. END ConvertH;
  164.  
  165. (*------------------------------------*)
  166. PROCEDURE ConvertHL* (x : LONGREAL; VAR d : ARRAY OF CHAR);
  167.  
  168. BEGIN (* ConvertHL *)
  169.   ConvertH (SHORT (x), d)
  170. END ConvertHL;
  171.  
  172. END Reals.
  173.  
  174. (***************************************************************************
  175.  
  176.   $Log: Reals.mod $
  177.   Revision 1.9  1995/06/04  23:26:41  fjc
  178.   - Release 1.6
  179.  
  180.   Revision 1.8  1995/06/04  23:24:07  fjc
  181.   - Release 1.6
  182.  
  183.   Revision 1.8  1995/06/04  23:24:07  fjc
  184.   - Release 1.6
  185.  
  186.   Revision 1.7  1995/05/08  17:19:37  fjc
  187.   - Added warning for the V40 mathieeesingbas SPMul/040 bug.
  188.  
  189.   Revision 1.6  1995/01/26  00:48:34  fjc
  190.   - Release 1.5
  191.  
  192.   Revision 1.5  1994/11/11  17:00:38  fjc
  193.   - Uses new external code interface.
  194.  
  195.   Revision 1.5  1994/11/11  17:00:38  fjc
  196.   - Uses new external code interface.
  197.  
  198.   Revision 1.4  1994/09/18  21:25:47  fjc
  199.   - Converted switches to pragmas/options
  200.  
  201.   Revision 1.1  1994/01/15  21:39:12  fjc
  202.   - Start of revision control
  203.  
  204. ***************************************************************************)
  205.